home *** CD-ROM | disk | FTP | other *** search
/ PC Graphics Unleashed / PC Graphics Unleashed.iso / ch18 / rad386 / torad.lsp < prev    next >
Encoding:
Lisp/Scheme  |  1993-07-15  |  32.2 KB  |  846 lines
  1. ;;; ***************************************************************************
  2. ;;;        torad.lsp
  3. ;;;        export RADIANCE scene description files from Autocad.
  4. ;;;
  5. ;;;        Copyright (C) 1993 by Georg Mischler / Lehrstuhl
  6. ;;;                              fuer Bauphysik ETH Zurich.
  7. ;;; 
  8. ;;;        Permission to use, copy, modify, and distribute this software
  9. ;;;        for any purpose and without fee is hereby granted, provided
  10. ;;;        that the above copyright notice appears in all copies and that
  11. ;;;        both that copyright notice and this permission notice appear in
  12. ;;;        all supporting documentation.
  13. ;;;
  14. ;;;        THIS SOFTWARE IS PROVIDED "AS IS" WITHOUT EXPRESS OR IMPLIED
  15. ;;;        WARRANTY.  ALL IMPLIED WARRANTIES OF FITNESS FOR ANY PARTICULAR
  16. ;;;        PURPOSE AND OF MERCHANTABILITY ARE HEREBY DISCLAIMED.
  17. ;;;
  18. ;;;        Acknowlegdements: 
  19. ;;;        Final developement of this program has been sponsored by Prof. Dr. 
  20. ;;;        B. Keller, Building Physics, Dep. for Architekture ETH Zurich. 
  21. ;;;        The developement environment has been provided by Prof. Dr.
  22. ;;;        G. Schmitt, Architecture & CAAD ETH Zurich. 
  23. ;;;
  24. ;;; ***************************************************************************
  25.  
  26. ;;; general environment setup.
  27. ;;; load compiled files if possible or else sources.
  28.  
  29. (progn
  30.   (setq *torad_preverr* *error*
  31.         *error* '((msg)
  32.                   (setq *error* *torad_preverr*)
  33.                   (prompt "Load failed for torad.lsp!\n")
  34.                   (if (null BD4A)
  35.           (prompt "Extended Lisp compiler not supported on this platform!\n"))
  36.                   (princ) ) )
  37.   (if (null *col*) (setq *col* 10))
  38.   (if (null  *toradtypelist*) (setq *toradtypelist*
  39.     '("3DFACE""TRACE""SOLID""LINE""PLINE""WPLINE""CIRCLE""ARC""PMESH""PFACE")) )
  40.   (if (null *exportsmode*) (setq *exportsmode* "Color" ))
  41.   (if (null *exportnsegs*) (setq *exportnsegs*  16     ))
  42.   (if (null *toraddlgpos*) (setq *toraddlgpos* '(-1 -1)))
  43.   (cond ( (null (or (and BD4A (load "esample.bi4" NIL)) (load "esample" NIL)))
  44.           (prompt "Can't load sampling functions from \"esample.lsp\"!\007\n")
  45.           (exit) )
  46.         (T NIL) )
  47.   (cond ( (null (or (and BD4A (load "vector.bi4"  NIL)) (load "vector"  NIL)))
  48.           (prompt "Can't load vector functions from \"vector.lsp\"!\007\n")
  49.           (exit) )
  50.         (T NIL) )
  51.   )
  52.  
  53.  
  54. ;;; ***************************************************************************
  55.  
  56. (defun *torad_error* (msg)
  57.   ;; error handling for torad.lsp.
  58.   (cond ( (and (/= "console break" msg)
  59.                (/= "Function cancelled" msg))
  60.           (terpri)
  61.           (princ msg) ))
  62.   (torad_reset) )
  63.  
  64.  
  65. (defun torad_setup ()
  66.   ;; global setup for torad.lsp.
  67.   (regapp "MKVOL_LSP_01")
  68.   (setq *Exportentlist* NIL
  69.         *exportblocklist* NIL
  70.         *FILE* NIL
  71.         *torad_preverr* *error*
  72.         *error* *torad_error*
  73. ))
  74.  
  75. (defun torad_reset ()
  76.   ;; global reset for torad.lsp.
  77.   (if *FILE* (close *FILE*))
  78.   (setq *error* *torad_preverr*
  79.         *error* *torad_preverr*
  80.         *FILE* NIL
  81.         *exportentlist* NIL
  82.         *exportblocklist* NIL
  83.         *valuablepolylist* NIL )
  84.   (princ) )
  85.  
  86.  
  87. ;;; ***************************************************************************
  88. (defun c:torad (/ stat fname selset blocklevel home dwg
  89.                    filelist matlist erot sun view)
  90.   ;; main control. 
  91.   (torad_setup)
  92.   (setq *exporttruelays* (vislaylist)) ; collect names of visible layers.
  93.   (if (and (wcmatch (getvar "acadver") "12*")
  94.           (findfile "torad.dcl") )
  95.       (setq stat (torad_dlg)
  96.             filelist *toradfilelist* )
  97.       (setq stat -1) )
  98.   (if (> 0 stat)
  99.       (setq filelist (setradparams)
  100.             *toradfilelist* filelist
  101.             stat 1) )
  102.   (cond ( (< 0 stat)
  103.           (setq  blocklevel 1)
  104.           (setq fname (strcase (cdr (assoc "prefix" filelist)) T))
  105.           (cond ( (and (assoc "files" filelist)
  106.                        (setq selset (ssget)) )
  107.                   (makeentlist )
  108.                   (setq *valuablepolylist* *toradtypelist*)
  109.                   (sampleents selset )
  110.                   (while *exportblocklist*
  111.                          (sampleblocks blocklevel )
  112.                          (setq blocklevel (1+ blocklevel)) )
  113.                   (setq matlist (writerad fname))
  114.                   (if (assoc "mat" filelist)
  115.                       (writeradmatlist fname matlist) )
  116.                   (if (setq erot (cdr (assoc "master" filelist)))
  117.                       (writeradtot fname erot matlist) )
  118.                   (if (assoc "make" filelist)
  119.                       (writeradmake fname matlist) ) )
  120.                 (T NIL) )
  121.           (if (setq view (cdr (assoc "view" filelist)))
  122.               (writeradview fname view) )
  123.           (if (setq sun (cdr (assoc "light" filelist)))
  124.               (writeradsun fname sun) )
  125.           )
  126.         (T NIL) )
  127.   (torad_reset ) )
  128.  
  129.  
  130.  
  131. ;;; GENERAL SETUP **********************************************************
  132.  
  133. ;;; currently supported entity types for torad.
  134. (setq *toradetypes* '(
  135.                 ("3DFACE"   "\n    Planarized faces of 3DFACEs" )
  136.                 ("TRACE"    "\n       Extruded and flat TRACEs" )
  137.                 ("SOLID"    "\n       Extruded and flat SOLIDs" )
  138.                 ("CIRCLE"   "\n      Extruded and flat CIRCLEs" )
  139.                 ("ARC"      "\n         Extruded faces of ARCs" )
  140.                 ("LINE"     "\n        Extruded faces of LINEs" )
  141.                 ("PLINE"    "\n    Extruded faces of 2D-PLINEs" )
  142.                 ("WPLINE"   "\n    Constant width of 2D-PLINES" )
  143.                 ("POLYGON"  "\nClosed 2d-polylines as POLYGONs" )
  144.                 ("PMESH"    "\n             Faces of 3D-MESHes" )
  145.                 ("PFACE"    "\n             Faces if POLYFACEs" )
  146.                 ("POINT"    "\n   Points as SPHEREs or BUBBLEs" )
  147.                 ))
  148.  
  149.  
  150.  
  151. (defun setradparams (/ filelist typelist types wcsrot dwg home fname)
  152.   ;; setup on older versions than 12.
  153.   (toradshowitems nil)
  154.   (prompt                 "\n\n       Entity data collected by:  ")
  155.   (princ *exportsmode*)
  156.   (prompt                   "\n Number of segments for circles:  ")
  157.   (princ *exportnsegs*)
  158.   (initget "Yes No")
  159.   (cond ( (= "Yes"
  160.              (getkword "\n\n        Do you want to change anything? <No>: "))
  161.           (terpri)
  162.           (foreach item *toradetypes*
  163.                    (toradsetitem (car item) nil))
  164.           (setsamplemode nil)
  165.           (setnumsegs nil)
  166.           )
  167.         ( T NIL) )
  168.   (initget "Yes No")
  169.   (cond ( (/= "No" (getkword   "\n       Write geometry data to file <Yes>?: "))
  170.           (setq filelist '(("files")))
  171.           (initget "Yes No")
  172.           (cond ( (= "Yes"
  173.                      (getkword "\n      Write organizing control-file <No>?: "))
  174.                   (setq wcsrot
  175.                       (getreal "\n WCS rotation from East to X <0.0>: ")
  176.                       filelist (cons (cons "master" (if wcsrot wcsrot 0.0))
  177.                                      filelist) )
  178.                   (initget "Yes No")
  179.                   (if (= "Yes"
  180.                      (getkword "\n  Write execution rules to makefile <No>?: "))
  181.                       (setq filelist (cons '("make") filelist)) ) ) )
  182.           (initget "Yes No")
  183.           (if (= "Yes"
  184.                  (getkword "\n Write materials (all same) to file <No>?: "))
  185.               (setq filelist (cons '("mat") filelist)) ) )
  186.         (T NIL) )
  187.   (initget "Yes No")
  188.   (if (= "Yes"
  189.          (getkword "\n            Write view to view-file <No>?: "))
  190.       (setq filelist (cons (cons "view" (askview)) filelist)) )
  191.   (initget "Yes No")
  192.   (if (= "Yes"
  193.          (getkword "\n       Write sun definition to file <No>?: "))
  194.       (setq filelist (cons (cons "light" (asksun)) filelist)) )
  195.   (setq dwg (getvar "DWGNAME")
  196.         fname (getstring
  197.                (strcat "\n\nprefix for output-file <" dwg ">: ")))
  198.   (if (= 0 (strlen fname)) (setq fname dwg))
  199.   (if (and (= "~" (substr fname 1 1))
  200.            (setq home (getenv "HOME")) )
  201.       (setq fname (strcat home (substr fname 2) )) )
  202.   (cons (cons "prefix" fname) filelist) )
  203.  
  204.  
  205.  
  206. (defun toradshowitems (stdalone / types typelist)
  207.   ;; display setting of sampled entity types.
  208.   (textpage)
  209.   (if stdalone (torad_setup))
  210.   (setq types *toradetypes*
  211.         typelist *toradtypelist* )
  212.           (prompt         "\n\n           TORAD sampling modes:")
  213.   (prompt                   "\n -------------------------------")
  214.                   (prompt "\n\n             Collected entities:\n")
  215.   (foreach item  types
  216.            (princ (strcat (cadr item) ":  "))
  217.            (princ (if (member (car item) typelist) "Y" "N")) )
  218.   (if stdalone (torad_reset)) )
  219.  
  220.  
  221.  
  222. (defun toradsetitem (item stdalone / types old new tstr oldl newl)
  223.   ;; set sampled entity types.
  224.   (if stdalone (torad_setup))
  225.   (initget "Yes No")
  226.   (setq oldl *toradtypelist*
  227.         types *toradetypes*
  228.         tstr (assoc item types)
  229.         old (if (member (car tstr) oldl) "Y" "N")
  230.         new (getkword (strcat (cadr tstr) " <" old ">: ")) )
  231.   (cond ( (and new (/= 0 (strlen new))
  232.                (/= old (setq new (substr new 1 1))))
  233.           (setq newl (if (= New "Y")
  234.                          (cons item oldl)
  235.                          (append (cdr (member item oldl))
  236.                                  (cdr (member item (reverse oldl))) ) ) )
  237.           (setq *toradtypelist* newl) )              
  238.         (T NIL) )        
  239.   (if stdalone (torad_reset)) )
  240.  
  241.  
  242. (defun askview (/ vlist num view res)
  243.   ;; set view number to export.
  244.   (setq vlist (list (cons 0 "Current"))
  245.         num 0
  246.         res -1)
  247.   (while (setq view (tblnext "VIEW" (not view)))
  248.          (setq num (1+ num)
  249.                vlist (cons (cons num (cdr (assoc 2 view))) vlist) ) )
  250.   (prompt "\nNUMBER  VIEW")
  251.   (prompt "\n------------\n")
  252.   (foreach item (reverse vlist)
  253.            (princ (car item))(princ (strcat "    " (cdr item) "\n")) )
  254.   (while (and res (or (> 0 res)(< num res)))
  255.          (setq res (getint "\n View Number <0>: ")) )
  256.   (if res res 0) )
  257.  
  258.  
  259. (defun asksun (/ vlist val)
  260.   ;; set lighting parameters.
  261.   (foreach item '(("\n     Hour <16.5>: " 16.5 T   )
  262.                   ("\n      Day   <01>: " 01   NIL )
  263.                   ("\n    Month   <08>: " 08   NIL )
  264.                   ("\n Timezone   <-1>: " -1   NIL )
  265.                   ("\n Latitude <47.5>: " 47.5 T   )
  266.                   ("\nLongitude <-8.5>: " -8.5 T   ) )
  267.            (if (null (setq val (if (last item)
  268.                                    (getreal (car item))
  269.                                    (getint (car item)) )))
  270.                (setq val (cadr item)) )
  271.            (setq vlist (cons (if (last item)(rtos val)(itoa val)) vlist)) )
  272.   vlist )
  273.  
  274.  
  275. ;;; SAMPLING SETUP ***********************************************************
  276.  
  277. (defun setradsamplemode (stdalone / samplemode)
  278.   ;; set sorting criteria.
  279.   (if stdalone (torad_setup))
  280.   (initget "Layer Toplayer Color")
  281.   (setq samplemode *exportsmode*
  282.         samplemode (getkword (strcat "\n\ncollect data by Color/Layer/Toplayer <"                                     samplemode ">: ") ) )
  283.   (if samplemode (setq *exportsmode* samplemode))
  284.   (if stdalone (torad_reset)) )
  285.  
  286.  
  287.  
  288. (defun setradnumsegs (stdalone / numsegs)
  289.   ;; set arc smoothing.
  290.   (if stdalone (torad_setup))
  291.   (setq numsegs *exportnsegs*
  292.         numsegs (getint (strcat "\nNumber of segments for circles (arcs) <"
  293.                                      (itoa numsegs) ">: ") ) )
  294.   (if numsegs (setq *exportnsegs* numsegs))
  295.   (if stdalone (torad_reset)) )
  296.  
  297.  
  298. ;;; DIALOG BOX CALL FOR TORAD *************************************************
  299.  
  300. (defun torad_dlg (/ dcl_id typelist dwgname dwgprefix num view viewlist stat)
  301.   ;; dialog box control for Autocad 12 and later (?).
  302.   (setq dwgname (getvar "dwgname")
  303.         dwgprefix (strcat (getvar "dwgprefix") "*")
  304.         num 0 )
  305.   (if (wcmatch dwgname dwgprefix)
  306.       (setq dwgname (strcat "./" (substr dwgname (strlen dwgprefix)))) )
  307.   ;; load and execute dialog if possible.
  308.   (setq dcl_id (load_dialog "torad.dcl"))
  309.   (cond ( (> 0 dcl_id)
  310.           (alert "\nCouldn't load dialog!")
  311.           (setq stat -1))
  312.         ( (not (new_dialog "radiance" dcl_id "" *toraddlgpos*))
  313.           (alert "\nCouldn't open dialog!")
  314.           (setq stat -1) )
  315.         (T
  316.          ;; setup view list.
  317.          (start_list "viewlist" 3)
  318.          (add_list "current")
  319.          (while (setq view (tblnext "VIEW" (not view)))
  320.                 (setq viewlist (cons (cons num view) viewlist)
  321.                       num (1+ num) )
  322.                 (add_list (cdadr view)) )
  323.          (end_list)
  324.          ;; setup entity types
  325.          (mapcar '(lambda (item)
  326.                           (set_tile (car item)
  327.                                     (if (member (car item) *toradtypelist*)
  328.                                         "1" "0" ) ) )
  329.                  *toradetypes*)
  330.          ;; setup filetypes section.
  331.          (mode_tile "viewlist"    1)
  332.          (mode_tile "sunvals"     1)
  333.          (mode_tile "masterblock" 1)
  334.          (mode_tile "prefix"      2)
  335.          ;; setup default values.
  336.          (set_tile "prefix"  dwgname)
  337.          (set_tile "make"    "1")
  338.          (set_tile "nsegs"   (itoa *exportnsegs*))
  339.          (set_tile "sample"  *exportsmode*)
  340.          ;; initialize callback functions.
  341.          (action_tile "files"  "(toggle_files)")
  342.          (action_tile "master" "(toggle_master)")
  343.          (action_tile "light"  "(toggle_light)")
  344.          (action_tile "view"   "(toggle_view)")
  345.          (action_tile "prefix" "(torad_enddlg)")
  346.          (action_tile "accept" "(torad_enddlg)")
  347.          (action_tile "cancel" "(torad_candlg)")
  348.          ;; go for it.
  349.          (setq stat (start_dialog))
  350.          (unload_dialog dcl_id)
  351.          ))
  352.   stat )
  353.  
  354.  
  355.  
  356. (defun toggle_light ()
  357.   ;; callback for sunlight toggle.
  358.   (cond ( (= "1" (get_tile "light"))
  359.           (mode_tile "sunvals" 0)
  360.           (mode_tile "long" 2) )
  361.         (T  (mode_tile "sunvals" 1)
  362.             (mode_tile "prefix" 2) ) ) )
  363.  
  364.  
  365.  
  366. (defun toggle_master ()
  367.   ;; calback for masterfile toggle.
  368.   (if (= "1" (get_tile "master"))
  369.       (mode_tile "masterblock" 0)
  370.       (mode_tile "masterblock" 1) ) )
  371.  
  372.  
  373.  
  374. (defun toggle_view ()
  375.   ;; callback for viewfile toggle.
  376.   (if (= "1" (get_tile "view"))
  377.       (mode_tile "viewlist" 0)
  378.       (mode_tile "viewlist" 1) ) )
  379.  
  380.  
  381.  
  382. (defun toggle_files ()
  383.   ;; callback for geometry files toggle.
  384.   (cond ( (= "1" (get_tile "files"))
  385.           (mode_tile "filelist" 0)
  386.           (mode_tile "modes" 0)
  387.           (mode_tile "auxf" 0)
  388.           (toggle_master) )
  389.         (T
  390.          (mode_tile "filelist" 1)
  391.          (mode_tile "modes" 1)
  392.          (mode_tile "auxf" 1) ) ) )
  393.  
  394.  
  395.  
  396. (defun torad_enddlg ()
  397.   ;; callback for accepting dialog.
  398.   ;; accepted if 'ok' or return in prefix field.
  399.   (cond ( (= 2 $reason) nil)
  400.         ( T (getraddlgvalues)) ) )
  401.  
  402.  
  403.  
  404. (defun getraddlgvalues (/ home filelist lightlist typelist nmodl samplebase
  405.               prefix errval make lightval radtypelist samplemode east numsegs)
  406.   ;; extract data if possible and close dialog box.
  407.   ;; else give alert and stay.
  408.   (cond ( (= "1" (get_tile "files"))
  409.           (setq typelist *toradetypes*)
  410.           (mapcar '(lambda (item)
  411.                            (if (= "1" (get_tile (car item)))
  412.                                (setq nmodl (cons (car item) nmodl)) ) )
  413.                   typelist )
  414.           (setq radtypelist nmodl
  415.                 samplemode (get_tile "sample")
  416.                 numsegs (read (get_tile "nsegs"))
  417.                 filelist '(("files"))
  418.                 samplebase '(("mat")("master")("make")("view")("light") ) ) )
  419.         (T (setq samplebase '(("view")("light"))) ) )
  420.   (mapcar '(lambda (item)
  421.                    (if (= "1" (get_tile (car item)))
  422.                        (setq filelist (cons item filelist)) ) )
  423.           samplebase )
  424.   (cond ( (assoc "master" filelist)
  425.           (setq east (read (get_tile "WCS rotation")))
  426.           (if (numberp east)
  427.               (setq filelist (subst (cons "master" east) '("master") filelist))
  428.               (setq errval "WCS rotation") ) )
  429.         (T (if (setq make (member '("make") filelist))
  430.                (setq filelist (append (cdr make)
  431.                                       (cdr (member '("make")
  432.                                                    (reverse filelist))))) ) ) )
  433.   (cond ( (assoc "light" filelist)
  434.           (mapcar '(lambda (item)
  435.                            (setq lightval (read (get_tile item)))
  436.                            (if (numberp lightval)
  437.                                (setq lightlist (cons (get_tile item) lightlist))
  438.                                (setq errval item) ) )
  439.                   '("Hour""Day""Month""TZ""Latitude""Longitude") )
  440.           (setq filelist (subst (cons "light" lightlist) '("light") filelist)) )
  441.         (T NIL) )
  442.   (if (assoc "view" filelist)
  443.       (setq filelist (subst (cons "view" (read (get_tile "viewlist")))
  444.                             '("view") filelist) ) )
  445.   (setq prefix (get_tile "prefix"))
  446.   (if (and (= "~" (substr prefix 1 1))
  447.            (setq home (getenv "HOME")) )
  448.       (setq prefix (strcat home (substr prefix 2))) )
  449.   (setq filelist (cons (cons "prefix" prefix) filelist))
  450.   (cond ( (and numsegs (not (numberp numsegs)))
  451.           (mode_tile "nsegs" 2)
  452.           (mode_tile "nsegs" 3)
  453.           (alert "Please enter a NUMBER for \"Number of Segments\" !") )
  454.         ( errval
  455.          (mode_tile errval 2)
  456.          (mode_tile errval 3)
  457.          (alert (strcat "Please enter a NUMBER for \"" errval "\" !")) )
  458.         (T (if numsegs (setq *exportnsegs*  numsegs))
  459.            (if samplemode (setq *exportsmode* samplemode))
  460.            (if filelist (setq *toradfilelist* filelist))
  461.            (if radtypelist (setq *toradtypelist* radtypelist))
  462.            (setq *toraddlgpos* (done_dialog 1)) ) ) )
  463.  
  464.  
  465.  
  466. (defun torad_candlg ()
  467.   ;; cancel button selected.
  468.   (setq *toraddlgpos* (done_dialog 0)) )
  469.  
  470.  
  471.  
  472. ;;; WRITES ******************************************************************
  473.  
  474. (defun writerad (fname / lplist lay radname radfname radfile ename matlist)
  475.   ;; open files for radiance geometry description.
  476.   (prompt "\nwriting out radiance-files:\n")
  477.   (foreach lplist *exportentlist*
  478.            (cond ( (cdr lplist)
  479.                (setq lay (strcase (strcat (if (= "Color" *exportsmode*)
  480.                                      "c_" "l_") (regulatename (car lplist)) ) T )
  481.                      radname (strcat (noprefix fname) "_" lay)
  482.                      radfname (strcat fname "_" lay ".rad") )
  483.                (cond ( (setq radfile (setq *FILE* (open radfname "w")))
  484.                        (writeradlist fname lplist lay radname radfname radfile)
  485.                        (setq matlist (cons (list lay radname radfname) matlist))
  486.                        (close radfile)
  487.                        (setq *FILE* NIL) )
  488.                      ( T (prompt "\nCan't open file \"" radfname
  489.                                  "\" for write! ") ) ) )
  490.                  (T NIL) ) )
  491.   matlist )
  492.  
  493.  
  494.  
  495. (defun writeradlist (fname lplist lay radname radfname radfile
  496.                            / ename contele num numstep numtot polylist)
  497.   ;; write radiance geometry description.
  498.   (princ (strcat "### Radiance scene-file:  " radfname) radfile)
  499.   (princ (strcat "\n### Created: " (datestring)) radfile)
  500.   (princ "\n### TORAD.LSP  by Georg Mischler\n\n" radfile)
  501.   (princ "### make sure material " radfile) (princ radname radfile)
  502.   (princ " is defined in a previous file!\n" radfile)
  503.   (princ "\n### polygons for object " radfile)
  504.   (princ  radname radfile) (princ "\n" radfile)
  505.   (setq num 0
  506.         numtot (length lplist)
  507.         numstep 0 )
  508.   (while (> numtot numstep)
  509.          (prompt (strcat "  file: " radfname "   "
  510.                          (itoa numstep) "/" (itoa numtot) " \r"))
  511.          (setq numstep (min (+ numstep 10) numtot))
  512.          (while (< num  numstep)
  513.                 (setq lplist (cdr lplist)
  514.                       ename (car lplist)
  515.                       num (1+ num) )
  516.                 (if (listp ename)
  517.                     (setq contele (reverse (cdr ename))
  518.                           ename (car ename))
  519.                     (setq contele nil) )
  520.                 (writeradents ename contele radfile radname num) ) )
  521.   (prompt (strcat "  file: " radfname "   " (itoa numstep) "       \n")) )
  522.  
  523.  
  524.  
  525. (defun writeradents (ename conte rfile radname num / typ data)
  526.   ;; dispatch entities to extraction and write functions.
  527.   (if ename (setq data (entget ename)
  528.                   TYP (getetype data) ))
  529.   (cond ( (valuablepoly typ)
  530.           (cond ( (equal typ    "LINE")
  531.                   (writeradpoly conte rfile radname num (linetopoly data)) )
  532.                 ( (equal typ   "PLINE")
  533.                   (writeradpoly conte rfile radname num
  534.                                 (plinetopoly data 1 *exportnsegs*)) )
  535.                 ( (equal typ "POLYGON")
  536.                   (writeradpoly conte rfile radname num
  537.                                 (plinetopoly data 2 *exportnsegs*)) )
  538.                 ( (equal typ  "WPLINE")
  539.                   (writeradpoly conte rfile radname num
  540.                                 (plinetopoly data 3 *exportnsegs*)) )
  541.                 ( (equal typ   "PMESH")
  542.                   (writeradpoly conte rfile radname num (meshtopoly data)) )
  543.                 ( (equal typ   "PFACE")
  544.                   (writeradpoly conte rfile radname num (pfacetopoly data)) )
  545.                 ( (equal typ  "3DFACE")
  546.                   (writeradpoly conte rfile radname num (facetopoly  data)) )
  547.                 ( (equal typ   "TRACE")
  548.                   (writeradpoly conte rfile radname num (tracetopoly data)) )
  549.                 ( (equal typ   "SOLID")
  550.                   (writeradpoly conte rfile radname num (tracetopoly data)) )
  551.                 ( (equal typ  "CIRCLE")
  552.                   (writeradcircle conte rfile radname num (circletorad data)) )
  553.                 ( (equal typ     "ARC")
  554.                   (writeradpoly conte rfile radname num
  555.                                 (arctopoly data *exportnsegs*)) )
  556.                 ( (equal typ   "POINT")
  557.                   (writeradpoint conte rfile radname num (pointtorad data)) )
  558.                 (T NIL) ) )
  559.         ( T NIL) ) )
  560.  
  561.  
  562.  
  563. (defun writeradpoly (contele radfile radname num polylist / len polnum)
  564.   ;; write polygon lists to file.
  565.   (if contele (setq polylist (trans_back polylist contele)))
  566.   ;(showpolylist polylist) ; visual debugging.
  567.   (setq polnum 0)
  568.   (foreach poly polylist
  569.            (cond ( (and poly (< 2 (setq len (length poly))))
  570.                    (setq polnum (1+ polnum))
  571.                    (princ (strcat "\n" radname " polygon " radname "."
  572.                                   (itoa num) "." (itoa polnum)) radfile )
  573.                    (princ "\n0\n0\n" radfile)
  574.                    (princ (* len 3) radfile)
  575.                    (foreach pt poly (printradpoint pt radfile))
  576.                    (princ "\n" radfile) )
  577.                  (T nil) ) ) )
  578.  
  579.  
  580.  
  581. (defun writeradcircle (contele radfile radname num polylist / len rad typ xname)
  582.   ;; write circles as rings cylinders or tubes.
  583.   (setq len (car polylist)
  584.         rad (cadr polylist)
  585.         xname (strcat radname "." (itoa num))
  586.         polylist (if contele (car (trans_back (caddr polylist) contele))
  587.                      (caaddr polylist) ) )
  588.   (cond ( (= 0.0 len)
  589.           (princ (strcat "\n" radname " ring " xname "\n0\n0\n8") radfile)
  590.           (printradpoint (car polylist) radfile)
  591.           (printradpoint (vector (car polylist)(cadr polylist)) radfile)
  592.           (princ (strcat "     0     " (rtos rad) "\n" ) radfile) )
  593.         ( T
  594.          (cond ( (> 0.0 len) (setq typ "tube"))
  595.                ( T (setq typ "cylinder")) )
  596.          (princ (strcat "\n" radname " " typ " " xname ".1\n0\n0\n7") radfile)
  597.           (printradpoint (car polylist) radfile)
  598.           (printradpoint (cadr polylist) radfile)
  599.           (princ (strcat "     " (rtos rad) "\n") radfile)
  600.           (princ (strcat "\n" radname " ring " xname ".2\n0\n0\n8") radfile)
  601.           (printradpoint (cadr polylist) radfile)
  602.           (printradpoint (vector (car polylist)(cadr polylist)) radfile)
  603.           (princ (strcat "     0     " (rtos rad) "\n" ) radfile)
  604.           (princ (strcat "\n" radname " ring " xname ".3\n0\n0\n8") radfile)
  605.           (printradpoint (car polylist) radfile)
  606.           (printradpoint (vector (cadr polylist)(car polylist)) radfile)
  607.           (princ (strcat "     0     " (rtos rad) "\n" ) radfile) ) ) )
  608.  
  609.  
  610.  
  611. (defun writeradpoint (conte rfile rname num polylist / center radius typ xname)
  612.   ;; write point entities to file as spheres or bubbles.
  613.   (setq radius (car polylist))
  614.   (if (= 0.0 radius) (setq radius (getvar "PDSIZE")))
  615.   (cond ( (= 0.0 radius) NIL)
  616.         ( (< 0.0 radius) (setq typ "sphere"))
  617.         ( (> 0.0 radius) (setq typ "bubble")) )
  618.   (cond ( typ
  619.          (setq xname (strcat rname "." (itoa num))
  620.                center (caar (if conte
  621.                                 (trans_back (cadr polylist) conte)
  622.                                 (cadr polylist) ))
  623.                )
  624.          (princ (strcat "\n" rname " " typ " " xname "\n0\n0\n4") rfile)
  625.          (printradpoint center rfile)
  626.          (princ (strcat "     " (rtos radius) "\n") rfile) ) ) )
  627.  
  628.  
  629.  
  630. (defun printradpoint (point radfile)
  631.   ;; write a single vertex to file.
  632.   (foreach number point
  633.            (princ "     " radfile)
  634.            (princ (shortnumstr number 11) radfile) )
  635.            (princ "\n" radfile) )
  636.  
  637.  
  638.  
  639. ;;; WRITE ADDITIONAL CONTROL INFORMATION ************************************
  640.  
  641. (defun writeradsun (fname sun / sunfname sfname sunfile)
  642.   ;; write a file containing a description of natural lighting.
  643.   ;; generate a call to gensky and the source for the sky for time and place.
  644.   (setq sunfname (strcat fname ".sun")
  645.         sfname (noprefix sunfname) )
  646.   (cond ( (setq sunfile (setq *FILE* (open sunfname "w")))
  647.           (princ (strcat "\nCreating sun-file: " sunfname))
  648.           (princ (strcat "### Radiance Sun-definition-file: " sfname) sunfile)
  649.           (princ (strcat "\n### Created: " (datestring)) sunfile)
  650.           (princ "\n### TORAD.LSP  by Georg Mischler\n" sunfile)
  651.           (princ "\n### Sun and sky definition at:" sunfile)
  652.           (princ (strcat "\n###     Longitude: " (nth 0 sun)) sunfile)
  653.           (princ (strcat "\n###      Latitude: " (nth 1 sun)) sunfile)
  654.           (princ (strcat "\n###      Timezone: " (nth 2 sun)) sunfile)
  655.           (princ (strcat "\n###         Month: " (nth 3 sun)) sunfile)
  656.           (princ (strcat "\n###           Day: " (nth 4 sun)) sunfile)
  657.           (princ (strcat "\n###          Hour: " (nth 5 sun)) sunfile)
  658.           (princ "\n\n!gensky " sunfile)
  659.           (princ (strcat (nth 3 sun) " " (nth 4 sun) " " (nth 5 sun)) sunfile)
  660.           (princ (strcat " -o " (car sun) " -a " (cadr sun)) sunfile)
  661.           (princ (strcat " -m " (rtos (* 15 (read (caddr sun)))) "\n") sunfile)
  662.           (princ "\nskyfunc glow skyglow\n0\n0\n4 0.9 0.9 1 0\n" sunfile)
  663.           (princ "\nskyglow source sky\n0\n0\n4 0 0 1 180\n" sunfile) )
  664.         (T (princ (strcat "\nCan't open material-file " sunfname
  665.                           " for write."))) ) )
  666.  
  667.  
  668.  
  669. (defun writeradmatlist (fname matlist / matfname matfile sfname)
  670.   ;; write a list of materials from the used modifier names.
  671.   ;; materials are all plastic of a constant grey.
  672.   (setq matfname (strcat fname ".mat")
  673.         sfname (noprefix fname) )
  674.   (cond ( (setq matfile (setq *FILE* (open matfname "w")))
  675.           (princ (strcat "\nCreating material-file: " matfname))
  676.           (princ (strcat "### Radiance material-file:  " sfname ".mat") matfile)
  677.           (princ (strcat "\n### Created: " (datestring)) matfile)
  678.           (princ "\n### TORAD.LSP  by Georg Mischler\n\n" matfile)
  679.  
  680.           (foreach mat matlist
  681.                    (princ (strcat "\nvoid plastic " (cadr mat)) matfile)
  682.                    (princ "\n0\n0\n5 0.65 0.65 0.65 0.0 0.0\n" matfile)
  683.           )
  684.           (close matfile)
  685.           (setq *FILE* NIL) )
  686.         (T (princ (strcat "\nCan't open material-file " matfname
  687.                           " for write." ))) ) )
  688.  
  689.  
  690.  
  691. (defun writeradtot (fname erot matlist / totfname totfile sfname infunc)
  692.   ;; write a controlling master file to combine all the written data
  693.   ;; into a complete RADIANCE scene description.
  694.   (setq totfname (strcat fname ".rad")
  695.         sfname (noprefix fname)
  696.         infunc (if (/= 0.0 erot)
  697.                    (strcat "\n!xform -rz " (rtos erot) " ")
  698.                    "\n!cat " ) )
  699.   (cond ( (setq totfile (setq *FILE* (open totfname "w")))
  700.           (princ (strcat "\nCreating Master-file: " totfname))
  701.           (princ (strcat "### Radiance Master-file: " sfname ".rad") totfile)
  702.           (princ (strcat "\n### Created: " (datestring)) totfile)
  703.           (princ "\n### TORAD.LSP  by Georg Mischler\n\n" totfile)
  704.           (if (assoc "light" *toradfilelist*)
  705.               (princ (strcat infunc sfname ".sun\n\n") totfile) )
  706.           (if (assoc "mat" *toradfilelist*)
  707.               (princ (strcat "!cat " sfname ".mat\n\n") totfile) )
  708.           (foreach mat matlist
  709.                    (princ (strcat "!cat " (cadr mat) ".rad\n" ) totfile) )
  710.           (close totfile)
  711.           (setq *FILE* NIL) )
  712.         (T (princ (strcat "\nCan't open Master-file "
  713.                           totfname " for write.") )) ) )
  714.  
  715.  
  716.  
  717. (defun writeradview (fname viewnum / viewfname vdir vpoint vmode target
  718.                            lensl twist zvect vsize vlist viewfile)
  719.   ;; write a RADIANCE viewfile either from the current view or
  720.   ;; from a named view from the view table.
  721.   (setq viewfname (strcat fname ".view"))
  722.   (cond ( (= 0 viewnum)
  723.           (setq vdir (trans (getvar "VIEWDIR") 1 0 T)
  724.                 vmode (getvar "VIEWMODE")
  725.                 target (if (= 0 vmode)(getvar "VIEWCTR")(getvar "TARGET"))
  726.                 vpoint (transl-p (trans target 1 0 T)  vdir 1.0)
  727.                 lensl (getvar "LENSLENGTH")
  728.                 twist (getvar "VIEWTWIST")
  729.                 zvect (trans '(0.0 1.0 0.0) 2 0 T) ) )
  730.         (T
  731.          (repeat viewnum (setq vlist (tblnext "VIEW" (not vlist))) )
  732.          (setq vdir (cdr (assoc 11 vlist))
  733.                vmode (cdr (assoc 71 vlist))
  734.                target (cdr (if (= 0 vmode) ; keep it simple...
  735.                                (append (mapcar '+ (assoc 10 vlist)
  736.                                        (assoc 12 vlist) )'(0.0))
  737.                                (assoc 12 vlist) ))
  738.                vpoint (transl-p target vdir 1.0)
  739.                lensl (cdr (assoc 42 vlist))
  740.                twist (cdr (assoc 50 vlist))
  741.                zvect (vect-prod '(0.0 0.0 1.0) vdir)
  742.                zvect (if (equal '(0.0 0.0 0.0) zvect 0.0000001)
  743.                          '(0.0 0.1 0.0)
  744.                          (vect-prod vdir zvect) ) ) ) )
  745.   (if (= 0 vmode)
  746.       (setq vsize (rtos (getvar "VIEWSIZE")))
  747.       (setq vsize (rtos (/ (* 360 (atan (/ 12.0 lensl))) pi))) )
  748.   (setq vdir (mapcar '- vdir))
  749.   (if (and (< 0 viewnum) (/= 0.0 twist))
  750.       (setq zvect (transf-p zvect (rot-3d-matrix (normalize vdir) twist))) )
  751.   (if (and (< 0.7 (caddr zvect))(= 0.0 twist))
  752.       (setq zvect '(0.0 0.0 1.0)) )
  753.   (cond ( (setq viewfile (setq *FILE* (open viewfname "w")))
  754.           (princ (strcat "\nCreating View-file: " fname ".view"))
  755.           (princ "rview -vt" viewfile)
  756.           (princ (if (= 1 vmode) "v -vp " "l -vp ") viewfile)
  757.           (mapcar '(lambda (pt) (princ (strcat (rtos pt) " ") viewfile)) vpoint )
  758.           (princ " -vd " viewfile)
  759.           (mapcar '(lambda (pt) (princ (strcat (rtos pt) " ") viewfile)) vdir)
  760.           (princ " -vu " viewfile)
  761.           (mapcar '(lambda (pt) (princ (strcat (rtos pt) " ") viewfile)) zvect )
  762.           (princ (strcat " -vh " vsize " -vv " vsize " -vs 0 -vl 0\n") viewfile)
  763.           (close viewfile)
  764.           (setq *FILE* NIL) )
  765.         (T (princ (strcat "\nCan't open view-file "
  766.                                     viewfname " for write." ))) ) )
  767.  
  768.  
  769.  
  770. (defun writeradmake (fname matlist / makefname makefile sfname)
  771.   ;; write a makefile for the UNIX utility make containing rules for
  772.   ;; octree conversion, previewing with rview and batch rendering with rpict.
  773.   (setq sfname (noprefix fname)
  774.         makefname (strcat (substr fname 1 (- (strlen fname)
  775.                                              (strlen sfname))) "makefile" ) )
  776.   (cond ( (setq makefile (setq *FILE* (open makefname "w")))
  777.           (princ (strcat "\nCreating makefile: " makefname))
  778.           (princ (strcat "### makefile for Radiance-file: "sfname".rad")makefile)          (princ (strcat "\n### Created: " (datestring)) makefile)
  779.           (princ "\n### TORAD.LSP  by Georg Mischler\n\n" makefile)
  780.           (princ "\nall:\n\t@echo \"  make what?\"" makefile)
  781.           (princ "\n\t@echo \"  enter \\\"make view\\\" or \\\"make pict\\\"\"\n" makefile)
  782.           (princ (strcat "\nview:" sfname ".oct") makefile)
  783.           (princ (strcat "\n\trview -ab 2 -vf " sfname".view "
  784.                          sfname".oct &\n")makefile)
  785.           (princ (strcat "\npict:" sfname ".oct") makefile)
  786.           (princ (strcat "\n\trpict -ab 2 -vf " sfname".view "
  787.                          sfname".oct > " sfname ".pic &\n")makefile)
  788.           (princ (strcat "\n" sfname ".oct: ") makefile)
  789.           (princ (strcat " \\\n         " sfname ".rad ") makefile)
  790.           (foreach mat matlist
  791.                    (princ (strcat " \\\n         " (cadr mat) ".rad") makefile))
  792.           (princ (strcat "\n\toconv "sfname".rad > "sfname".oct\n") makefile)
  793.           (princ (strcat "\nclean:\n\t @rm " sfname".oct\n") makefile)
  794.           (close makefile)
  795.           (setq *FILE* NIL) )
  796.         (T (princ (strcat "\nCan't open makefile "
  797.                           makefname " for write." ))) ) )
  798.  
  799.  
  800. ;;; ***************************************************************************
  801. (defun regulatename (name / pos char)
  802.   ;; eliminate illegal characters in filenames.
  803.   (setq pos 1)
  804.   (repeat (strlen name)
  805.           (setq char (substr name pos 1))
  806.           (if (or (= char "|")(= char "$"))
  807.               (setq name (strcat (substr name 1 (1- pos))
  808.                                  "_"
  809.                                  (substr name (1+ pos)))))
  810.           (setq pos (1+ pos)) )
  811.   name )
  812.  
  813.  
  814. ;;;-----------------------------------------------------------------------------
  815. (defun circletorad (data / center1 center2 radius dist plist)
  816.   ;; extract a description of a circle for 'writeradcircle'.
  817.   (setq center1 (cdr (assoc 10 data))
  818.         radius (cdr (assoc 40 data))
  819.         dist (cdr (assoc 39 data))
  820.         center2 (list (car center1)(cadr center1)
  821.                       (+ (caddr center1) (if dist dist 1.0)) )
  822.         plist (trans_back (list (List center2 center1))
  823.                           (list (cdr (assoc -1 data)))) )
  824.   (list (if dist dist 0.0) radius plist) )
  825.  
  826.  
  827. ;;;-----------------------------------------------------------------------------
  828. (defun pointtorad (data / center rad)
  829.   ;; extract a description of a point for 'writeradpoint'.
  830.   (setq center (cdr (assoc 10 data))
  831.         rad (cdr (assoc 39 data))
  832.         rad (if (and rad (/= 0.0 rad)) rad 0.0) )
  833.   (list rad (list (list center))) )
  834.  
  835.  
  836. ;;; ***************************************************************************
  837.  
  838. (progn
  839.   (prompt   "\n-- TORAD.LSP  -  1993 by Georg Mischler --\n")
  840.   (prompt   "\n Enter \"TORAD\" for writing Radiance files.")
  841.   (torad_reset) )
  842.  
  843. ;;; ***************************************************************************
  844. ;;; end of torad.lsp.
  845. ;;; ***************************************************************************
  846.